home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 5 / Amiga Tools 5.iso / tools / developer-tools / andere sprachen / powerlogo-1.4 / utilities / system < prev    next >
Encoding:
Text File  |  1996-07-16  |  5.2 KB  |  163 lines
  1.  
  2. ;  ********************************************************************
  3. ;  Graphics Utilities
  4. ;  ********************************************************************
  5.  
  6. make "screen-data [
  7.    procedure [ [ :sd-screen ] [ ] [ :f ] ]
  8.    if = @0 :sd-screen [ make "sd-screen system 16 ] [ ]
  9.    make "f ( peek 2 :sd-screen 38 )
  10.    output ( list  ( +   if bitsetp 15 :f [ 1 ] [ 0 ]
  11.                         if bitsetp 2 :f [ 2 ] [ 0 ]
  12.                         if bitsetp 7 :f [ 4 ] [ 0 ] )
  13.                   ( peek 1 :sd-screen 189 )
  14.                   convertstring ( peek 0 :sd-screen 6.5 )
  15.                   ( peek -2 :sd-screen 4 )
  16.                   ( peek -2 :sd-screen 5 )
  17.                   ( peek -2 :sd-screen 6 )
  18.                   ( peek -2 :sd-screen 7 )
  19.                   ( peek 1 :sd-screen 330 )
  20.                   ( peek 1 :sd-screen 331 ) ) ]
  21.  
  22. make "window-data [
  23.    procedure [ [ :wd-window ] [ ] [ :f :s ] ]
  24.    if = @0 :wd-window [ make "wd-window system 15 ] [ ]
  25.    make "s ( peek 0 :wd-window 11.5 )
  26.    make "f ( peek 4 :wd-window 6 )
  27.    output ( list  if = :s system 16 [ @0 ] [ :s ]
  28.                   ( +   if bitsetp 1 :f [ 1 ] [ 0 ]
  29.                         if bitsetp 2 :f [ 2 ] [ 0 ]
  30.                         if bitsetp 3 :f [ 4 ] [ 0 ]
  31.                         if bitsetp 0 :f [ 8 ] [ 0 ]
  32.                         if bitsetp 10 :f [ 16 ] [ 0 ]
  33.                         if bitsetp 8 :f [ 32 ] [ 0 ]
  34.                         if bitsetp 11 :f [ 64 ] [ 0 ]
  35.                         if bitsetp 13 :f [ 128 ] [ 0 ] )
  36.                   convertstring ( peek 0 :wd-window 8 )
  37.                   ( peek -2 :wd-window 2 )
  38.                   ( peek -2 :wd-window 3 )
  39.                   ( peek -2 :wd-window 4 )
  40.                   ( peek -2 :wd-window 5 )
  41.                   ( peek 1 :wd-window 98 )
  42.                   ( peek 1 :wd-window 99 )
  43.                   ( peek -2 :wd-window 8 )
  44.                   ( peek -2 :wd-window 9 )
  45.                   ( peek -2 :wd-window 10 )
  46.                   ( peek -2 :wd-window 11 ) ) ]
  47.  
  48. make "turtle-data [
  49.    procedure [ [ :td-turtle ] [ ] [ :f ] ]
  50.    make "f ( peek 2 :td-turtle 40 )
  51.    output ( list  ( peek 0 :td-turtle 1 )
  52.                   ( peek 8 :td-turtle 3 )
  53.                   /  +- ( peek 8 :td-turtle 4 )
  54.                      ( peek 8 :td-turtle 3 )
  55.                   ( peek 8 :td-turtle 5 )
  56.                   ( peek 8 :td-turtle 6 )
  57.                   ( peek 8 :td-turtle 7 )
  58.                   if bitsetp 3 :f [ -1 ] [ 0 ] ) ]
  59.  
  60. make "bitsetp [
  61.    procedure [ [ :bs-bit :bs-data ] [ ] [ :t ] ]
  62.    make "t 2147483648
  63.    while [ < :bs-bit 31 ]
  64.    [  if >= :bs-data :t [ make "bs-data - :bs-data :t ] [ ]
  65.       make "t / :t 2
  66.       inc "bs-bit ]
  67.    output >= :bs-data :t ]
  68.  
  69. ; WINDOW-SIZE **********************************************************
  70. ;    Output the limits for the cursor for the command window.
  71.  
  72. make "window-size [
  73.   procedure [ [ ] [ ] [ :_ws_pos :_ws_lim ] ]
  74.   make "_ws_pos cursor
  75.   setcursor [ 10000 10000 ]
  76.   make "_ws_lim cursor
  77.   setcursor :_ws_pos
  78.   op list + first :_ws_lim 1 + last :_ws_lim 1 ]
  79.  
  80.  
  81. ;  ***************************************************************
  82. ;  ***   Requests
  83. ;  ***************************************************************
  84.  
  85. ; *** Yes or no requester
  86.  
  87. make "requester [
  88.    procedure [ [ :screen :q1-text ]
  89.                [ :q2-text :yes-text :no-text :title-text ]
  90.                [ :w :m :x ] ]
  91.    while [ mousep ] [ ignore getmouse ]
  92.    if emptyp :yes-text [ make "yes-text "YES ] [ ]
  93.    if emptyp :no-text [ make "no-text "NO ] [ ]
  94.    if emptyp :title-text [ make "title-text [ LOGO Request! ] ] [ ]
  95.    make "w ( openwindow :screen 131 :title-text 0 0 240 52 )
  96.    setpen :w 1
  97.    rectfill :w 4 12 235 48
  98.    setpen :w 0
  99.    setdrmode :w 0
  100.    move :w 8 20
  101.    text :w :q1-text
  102.    move :w 8 30
  103.    text :w :q2-text
  104.    move :w - 50 * 4 count :yes-text 43
  105.    text :w :yes-text
  106.    move :w - 189 * 4 count :no-text 43
  107.    text :w :no-text
  108.    drawbox :w 10 34 80 12
  109.    drawbox :w 149 34 80 12
  110.    while [ true ]
  111.    [  make "m getmouse
  112.       if = :w first :m
  113.       [  make "x item 2 :m
  114.          if >> 34 46 item 3 :m
  115.          [  if >> 10 90 :x
  116.             [  closewindow :w
  117.                op true ]
  118.             [  if >> 149 229 :x
  119.                [  closewindow :w
  120.                   op false ] [ ] ] ] [ ] ] [ ] ] ]
  121.                
  122. ; *** alert 
  123.  
  124. make "alert [
  125.    procedure [ [ :screen :q1-text ]
  126.                [ :q2-text :yes-text :title-text ]
  127.                [ :w :m ] ]
  128.    while [ mousep ] [ ignore getmouse ]
  129.    if emptyp :yes-text [ make "yes-text "OK ] [ ]
  130.    if emptyp :title-text [ make "title-text [ LOGO Alert! ] ] [ ]
  131.    make "w ( openwindow :screen 131 :title-text 0 0 240 52 )
  132.    setpen :w 1
  133.    rectfill :w 4 12 235 48
  134.    setpen :w 0
  135.    setdrmode :w 0
  136.    move :w 8 20
  137.    text :w :q1-text
  138.    move :w 8 30
  139.    text :w :q2-text
  140.    move :w - 50 * 4 count :yes-text 43
  141.    text :w :yes-text
  142.    drawbox :w 10 34 80 12
  143.    while [ true ]
  144.    [  make "m getmouse
  145.       if = :w first :m
  146.       [  if >> 34 46 item 3 :m
  147.          [  if >> 10 90 item 2 :m
  148.             [  closewindow :w
  149.                stop ] [ ] ] [ ] ] [ ] ] ]
  150.                
  151. ; *** simple rectangle
  152.  
  153. if buriedp "drawbox [ ] [
  154. make "drawbox [
  155.    procedure [ [ :box-w :le :te :w :h ] ]
  156.    move :box-w :le :te
  157.    draw :box-w + :le :w :te
  158.    draw :box-w + :le :w + :te :h
  159.    draw :box-w :le + :te :h
  160.    draw :box-w :le :te ]
  161. ]
  162.  
  163.